#light
(* 
After doing a bit of research, it appears the fastest way to load read-only xml
is using an xpath document.  Most documents in a multi-document system will
be read only, at least most of the time.  Hopefully, operations using msxml's
xpath and schema system should be robust and quite quick.

The problem is that the xpathdocument systems don't retain schema info.  It
would be interesting if you could have a cursor based system, such that it
re-validated to where the cursor was to figure out the document's state.
This would be awesome, IMHO, because you could use XPathDocument along
with the schema info, and get very quick read-only typed access.

I don't feel like implementing that right now, however, so the xml document's
somewhat-half-thought-out system will have to do.

Given a set of schemas, when you load a document it should be fully or mostly
checked against a schema.  The xpath system should use the schema in order to
create some new nodes and there will be systems built on top that walk through
the datatypes; so they can find all id's in a document, for instance.

Doing XML this way seems a lot smarter than the naive way, and it seems to be
perfect for large systems where you don't need to know about most of the data.

Tests should include datatype lookups, ensuring that node creation gets a new
schema item so that default values and new id's can be recorded, and checking out
how the intermixing of schema documents works for items embedded in other documents.

*)

module CGraph.CGXml
open System.Collections.Generic
open System.Xml
open System.Xml.XPath
open System.Xml.Schema
open CGraph.Generic
open CGraph.Generic.Algorithms

    
type DocumentHandle = { Handle:int }

type ElementHandle = { Handle:int }

    
/// Callback type = handle to reference the data, namespace name schema information

type ElementOrAttribute = { Element:ElementHandle; Attribute:(string*string) option }

/// Callback = elemOrAtt,namespace,name,schemaInfo,value
type FindTypeCallback = delegate of ElementOrAttribute*string*string*IXmlSchemaInfo*string -> unit
type DocumentHandleMap = HandleMap<XmlNode>
    

let MatchQualifiedName (ns:string,dtype:string) (name:XmlQualifiedName) =
    if ns = name.Namespace && dtype = name.Name 
        then true
        else false
        
let rec SchemaTypesAndDerived (stype:XmlSchemaType) =
    seq {
        yield stype
        if stype.BaseXmlSchemaType <> null
            then yield! SchemaTypesAndDerived stype.BaseXmlSchemaType
    }

let IsTypeOrDerivedFromSchemaType (stype:XmlSchemaType) dtype =
    let matchType = 
        SchemaTypesAndDerived stype
        |> Seq.first( 
            fun(stype)->
                if MatchQualifiedName dtype stype.QualifiedName
                    then Some dtype
                    else None )
    matchType
        
                

let IsTypeOrDerivedFrom dtype (info:IXmlSchemaInfo) =
    match info with
        | null -> None
        | _ -> 
            IsTypeOrDerivedFromSchemaType info.SchemaType dtype 
            
let IsListTypeSchemaType (stype:XmlSchemaType) =
    SchemaTypesAndDerived stype
    |> Seq.first( 
        fun (stype)->
            match stype with
                | :? XmlSchemaSimpleType as simple ->
                    if simple.Content <> null && ( simple.Content :? XmlSchemaSimpleTypeList )
                        then Some simple
                        else None 
                | _ -> None )
            
let IsListType (info:IXmlSchemaInfo) =
    match info with
        | null -> None
        | _ -> IsListTypeSchemaType info.SchemaType 
      
type StringOrList =
    | SLString of string
    | SLList of string array
    
let ToListValues value stype =
    match IsListTypeSchemaType stype with
        | None -> SLString(value)
        | Some simple -> SLList (value.Split [|' '|])
        
    
///Cache the result of a given search as of if a type
///is derived or not.    
type DatatypeSearchContext(m_types:(string*string) seq) =
    let m_searches = System.Collections.Generic.Dictionary<XmlSchemaType,(string*string) option>()
    
    member s.IsTypeOrDerived stype =
        let result = 
            let success,item = m_searches.TryGetValue stype
            if success 
                then item
                else
                    let temp = 
                        m_types 
                        |> Seq.first (IsTypeOrDerivedFromSchemaType stype)
                    m_searches.Add(stype,temp)
                    temp
        result

//Walk every type in the document checking if the type is a target
//type or derived from a target type.
let rec FindDatatypes (types:DatatypeSearchContext) (handles:XmlElement->ElementHandle) (node:XmlNode) (callback:FindTypeCallback) =
    let nodeHdl = handles (node:?>XmlElement)
    let matchTypes (node:XmlNode) = 
        if node.SchemaInfo <> null && node.SchemaInfo.SchemaType <> null
            then
                match types.IsTypeOrDerived node.SchemaInfo.SchemaType with
                    | Some ptype->
                        let ns,name = ptype
                        let attOption,value,hdl = 
                            match node with //If attribute, use the overlying nodes handle
                                | :? XmlAttribute as att -> Some (att.NamespaceURI,att.Name),att.Value,nodeHdl
                                //If element, then create a new handle.
                                | _ -> None,XmlNodeValue node,handles( (node:?>XmlElement) )
                        let elemOrAtt = { Element=hdl; Attribute=attOption }
                        callback.Invoke (elemOrAtt,ns,name,node.SchemaInfo,value)
                    | None -> ()
                                
    (*Useful debugging code if shizzle isn't working the way you want it to.
    let elemType =
        if (node :? XmlElement)
            then (node :?> XmlElement).Name
            else ""
    if ( elemType = "IDREF_array" ) 
        then
            let types = System.Collections.Generic.List<XmlSchemaType>(SchemaTypesAndDerived node.SchemaInfo.SchemaType)
            for t in types do
                printfn "name is: %s"  t.QualifiedName.Name |> ignore*)
        
    matchTypes node
    
    XmlNodeAtts node 
        |> Seq.iter(
            fun(att)->matchTypes (att :> XmlNode))
    
    let findDTypes (node:XmlElement) = FindDatatypes types handles (node :> XmlNode) callback
    
    XmlNodeChildren node |> Seq.iter findDTypes
      
(*
            Tuple<string, string>[] knownPaths = new Tuple<string, string>[] {
                new Tuple<string,string>( "http://www.w3.org/2001/03/schema.xsd", Path.GetFullPath(DataDir + "XMLSchema.xsd") )
                , new Tuple<string,string>( "http://www.w3.org/2001/03/xml.xsd", Path.GetFullPath(DataDir + "xml.xsd") )
                , new Tuple<string,string>( "-//W3C//DTD XMLSCHEMA 200102//EN", Path.GetFullPath(DataDir + "XMLSchema.dtd") )
                , new Tuple<string,string>( "datatypes.dtd", Path.GetFullPath(DataDir + "datatypes.dtd") )
            };
            Tuple<string, string>[] namesAndSchemas = new Tuple<string, string>[] {
                new Tuple<string,string>( "http://www.collada.org/2005/11/COLLADASchema", Path.GetFullPath(DataDir + "collada_schema_1_4_1.xsd") )
            };
            XmlUrlResolver resolver =CGraph.CGXmlXp.CreateCustomResolver( new Tuple<string,string>[] {
            } );


            XmlSchemaSet schemaSet = CGraph.CGXmlXp.CreateSchemaSet(knownPaths, namesAndSchemas);
*)
  
/// Create an XmlUrlResolver with certain
/// URI's overridden.
let CreateCustomResolver paths =
    { new XmlUrlResolver() as base
      with 
        override s.ResolveUri (uri,path) =
            let str = 
                paths
                |> Seq.first( 
                    fun(webPath,filePath) ->
                        if path = webPath
                            then Some filePath
                            else None );
            match str with
                | Some str -> System.Uri( "file://" + str )
                | None -> base.ResolveUri (uri,path)
     }
   
/// Create a compiled schema set using this set of known document
/// paths and reading/compiling this set of names and schemas.  
let CreateSchemaSet (knownPaths,namesAndSchemas) =
    let resolver = CreateCustomResolver knownPaths
    let retval = XmlSchemaSet()
    retval.XmlResolver <- resolver
    for (name:string),(filePath:string) in namesAndSchemas do
        let settings = XmlReaderSettings();
        settings.ProhibitDtd <- false;
        let reader = XmlReader.Create(filePath, settings);
        retval.Add(name,reader) |> ignore
    retval.Compile()
    retval
    
type ElementEntry = { Element:XmlElement; Handle:int }    
type ElementEntryCollection = MultiCollection<ElementEntry>
type ElementEntryHandleIndex() =
    inherit MultiCollectionIndex<ElementEntry,int>(fun entry -> Some entry.Handle)
type ElementEntryElementIndex() =
    inherit MultiCollectionIndex<ElementEntry,XmlElement>(fun entry -> Some entry.Element)
    

type DocEntry = { Document:XmlDocument; Path:string; Handle:int; 
    Entries:ElementEntryCollection }
    
let createDocEntry doc path hdl 
    (hdlIdx:ElementEntryHandleIndex) (elemIdx:ElementEntryElementIndex ) =
    let entryCollection = MultiCollection<ElementEntry>()
    entryCollection.AddSubCollection hdlIdx
    entryCollection.AddSubCollection elemIdx
    { Document=doc; Path=path; Handle=hdl; Entries=entryCollection }

type DocEntryCollection = MultiCollection<DocEntry>
type DocEntryHandleIndex() = 
    inherit MultiCollectionIndex<DocEntry,int>(fun entry -> Some entry.Handle)
type DocEntryDocumentIndex() = 
    inherit MultiCollectionIndex<DocEntry,XmlDocument>(fun entry -> Some entry.Document)
type DocEntryPathIndex() = 
    inherit MultiCollectionIndex<DocEntry,string>(fun entry -> Some entry.Path)
    
let createDocEntryCollection() =
    let retval = MultiCollection<DocEntry>()
    let handleIdx = DocEntryHandleIndex()
    let documentIdx = DocEntryDocumentIndex()
    let pathIdx = DocEntryPathIndex()
    retval.AddSubCollection handleIdx
    retval.AddSubCollection documentIdx
    retval.AddSubCollection pathIdx
    retval,handleIdx,documentIdx,pathIdx

///The code/value ratio seems to be very low for xml.  Why is something like
///this so darn complex?
type DocumentGroup(m_schemas:XmlSchemaSet) =
    
    let m_docs,m_handlIdx,m_documentIdx,m_pathIdx = createDocEntryCollection()
    let m_elementHdlIdx = ElementEntryHandleIndex()
    let m_elementElementIdx = ElementEntryElementIndex()
    let m_handles = Incrementor<int>((fun(arg)->arg+1),1)
    
    let m_loadedFire, m_loadedEvent = IEvent.create<DocumentHandle>()
    /// Old value, new value, document
    let m_pathFire, m_pathEvent = IEvent.create<DocumentHandle*string*string>()
    
    ///Document handle
    let m_preSaveFire, m_preSaveEvent = IEvent.create<DocumentHandle>()    
    
    //Path, parent, index, child
    let m_preNodeRemoveFire, m_preNodeRemoveEvent = IEvent.create<ElementHandle*int*ElementHandle>()
    //Path, parent, index, child
    let m_postNodeRemoveFire, m_postNodeRemoveEvent = IEvent.create<ElementHandle*int*ElementHandle>()
    
    //Path, parent, index, child
    let m_preNodeInsertFire, m_preNodeRemoveEvent= IEvent.create<ElementHandle*int*ElementHandle>()
    //Path, parent, index, child
    let m_postNodeInsertFire, m_postNodeRemoveEvent= IEvent.create<ElementHandle*int*ElementHandle>()
    
    //Item, namespace, name, oldVal, newVal
    let m_preAttributeSetFire, m_preAttributeSetEvent= IEvent.create<ElementHandle*string*string*string option*string option>()
    //Item, namespace, name, oldVal, newVal
    let m_postAttributeSetFire, m_postAttributeSetEvent= IEvent.create<ElementHandle*string*string*string option*string option>()
    
    //ElementHandle, oldVal, newVal
    let m_preElemTextSetFire, m_preElemTextSetEvent= IEvent.create<ElementHandle*string*string>()
    //ElementHandle, oldVal, newVal
    let m_postElemTextSetFire, m_postElemTextSetEvent= IEvent.create<ElementHandle*string*string>()
    
    /// Returns true if the document is loaded, false otherwise.
    /// Always loades the document
    member s.GetOrLoad path =
        let success,item = m_pathIdx.Items.TryGetValue path
        let retval = 
            if success 
                then 
                    { new DocumentHandle with Handle = item.Handle }
                else
                    let settings = XmlReaderSettings()
                    settings.Schemas <- m_schemas
                    settings.ValidationType <- ValidationType.Schema
                    let reader = XmlReader.Create (path,settings)
                    let newDoc = new XmlDocument()
                    newDoc.Load( reader )
                    s.AddDocument newDoc path
        success,retval
        
    member private s.AddDocument newDoc path =
        let entry = createDocEntry newDoc path m_handles.Next m_elementHdlIdx m_elementElementIdx
        m_docs.Add entry
        let retval = { new DocumentHandle with Handle=m_handles.Next }
        m_loadedFire(retval)
        retval
        
        
    member s.GetOrCreate path =
        let success,item = m_pathIdx.Items.TryGetValue path
        match success with
            | true -> true,{ new DocumentHandle with Handle = item.Handle }
            | false ->
                let newDoc = new XmlDocument()
                false,s.AddDocument newDoc path
                
    member private s.GetDocument (docHandle:DocumentHandle) =
        m_handlIdx.Items.[docHandle.Handle]
                
    member s.ChangeDocumentPath (docHandle,newPath) =
        let doc = s.GetDocument docHandle
        let oldPath = doc.Path
        m_docs.Remove doc |> ignore
        let doc = { doc with Path=newPath }
        m_docs.Add doc
        m_pathFire( docHandle,oldPath,newPath )
        
    member s.SaveDocument docHdl = 
        let doc = s.GetDocument docHdl
        m_preSaveFire( docHdl )
        doc.Document.Save( doc.Path )
     
    member s.DocumentElement docHandle =
        //Ensure we contain the path,
        //then return the handle for the document node
        let doc = s.GetDocument docHandle
        s.GetOrAddItem doc doc.Document.DocumentElement
        
    member private s.GetOrAddItem (docEntry:DocEntry) elem =
        let success,item = m_elementElementIdx.Items.TryGetValue elem
        if success
            then { new ElementHandle with Handle=item.Handle }
            else
                let entry = { Element = elem; Handle=m_handles.Next }
                docEntry.Entries.Add entry
                { new ElementHandle with Handle=entry.Handle }
                
    member private s.DocumentOf (elem:XmlElement) =
        m_documentIdx.Items.[elem.OwnerDocument]
        
    /// Create an alement with a given name and namespace.
    /// These are not editable once created, and thus there is no
    /// event for these.  You can add/remove them from children, and
    /// that is undoable.
    member s.CreateElem(docHandle,ns,name) =
        let docEntry = s.GetDocument docHandle
        let elem = docEntry.Document.CreateElement(name,ns)
        s.GetOrAddItem docEntry elem
        
    /// Remove a given element.  This just removes this
    /// object's reference to it, it doesn't remove the child
    /// or anything like that.  You need to do that with
    /// RemoveChild
    member s.RemoveElem hdl =
        let elem = m_elementHdlIdx.Items.[hdl]
        let docEntry = m_documentIdx.Items.[elem.Element.OwnerDocument]
        docEntry.Entries.Remove elem
    
    member private s.Node (hdl:ElementHandle) =
        m_elementHdlIdx.Items.[hdl.Handle].Element :> XmlNode
    
    member s.GetChildren hdl =
        let node = s.Node hdl
        let doc = m_documentIdx.Items.[node.OwnerDocument]
        XmlNodeChildren (s.Node hdl)
            |> Seq.map (fun(node)-> 
                s.GetOrAddItem doc node )
            
    member s.GetElemText (path,hdl) =
        let node = s.Node hdl
        XmlNodeValue node
        
   
    member s.GetAttributes hdl =
        let node = s.Node hdl
        XmlNodeAtts node
            |> Seq.map( fun(att)->att.NamespaceURI,att.Name,att.Value)
          
    member s.GetAttribute (hdl,ns,name) =
        let node = s.Node hdl
        let retval = node.Attributes.GetNamedItem(name,ns) :?> XmlAttribute
        if ( retval <> null && retval.Value.Length <> 0 )
            then Some retval.Value
            else None
    
    member s.GetValue (elemOrAtt:ElementOrAttribute) =
        match elemOrAtt.Attribute with
            | Some (ns,name) -> 
                let att = s.GetAttribute (elemOrAtt.Element,ns,name)
                match att with
                    | Some str -> str
                    | None -> ""
            | None -> 
                let node = s.Node elemOrAtt.Element
                XmlNodeValue node
                
    member s.GetSchemaType (eora:ElementOrAttribute) =
        let node = s.Node eora.Element
        let sinfo = 
            match eora.Attribute with
                | Some (ns,name) ->
                    let att = (node :?> XmlElement).GetAttributeNode(ns,name)
                    match att with
                        | null -> null
                        | _ -> 
                            if ( att.SchemaInfo <> null )
                                then att.SchemaInfo
                                else null
                | None -> node.SchemaInfo
        if sinfo <> null && sinfo.SchemaType <> null then Some sinfo.SchemaType else None
             
    member s.GetValues eora =
        let strVal = s.GetValue eora
        let stype = s.GetSchemaType eora
        match stype with
            | Some stype -> ToListValues strVal stype
            | None -> SLString(strVal)
        
    member s.GetElemName hdl =
        let node = s.Node hdl
        node.NamespaceURI,node.Name 
        
    member s.ParentOf hdl =
        let node = s.Node hdl
        let docEntry = m_documentIdx.Items.[node.OwnerDocument]
        let parent = 
            if (node.ParentNode :? XmlElement ) 
                then Some ( node.ParentNode :?> XmlElement )
                else None
             
        match parent with
            | Some rent -> Some (s.GetOrAddItem docEntry rent)
            | None -> None
        
        
    member s.IndexOf hdl =
        let node = s.Node hdl
        let parent = 
            if (node.ParentNode :? XmlElement ) 
                then Some ( node.ParentNode :?> XmlElement )
                else None
        match parent with
            | Some rent -> 
                let index = ref 0
                let indexOpt = 
                    XmlNodeChildren (rent :> XmlNode)
                    |> Seq.first( 
                        fun(child) ->
                            if ( child = (node :?> XmlElement) ) 
                                then Some (!index)
                                else
                                    index := !index + 1
                                    None )
                match indexOpt with
                    | Some idx -> idx
                    | None -> -1
            | None -> -1
        
    member s.RemoveChild hdl =
        let node = s.Node hdl
        let parent = s.ParentOf hdl
        match parent with
            | Some rent ->
                let childIdx = s.IndexOf hdl
                m_preNodeRemoveFire( rent,childIdx,hdl)
                s.NoEventRemoveChild( rent, hdl )
                m_postNodeRemoveFire (rent,childIdx,hdl)
                
            | None -> failwith "Node does not have a parent"
                
    /// Inserts the child such that children[childIdx] = child.
    /// Inserts before the current item at childIdx
    /// -1 for childIdx means insert at the end.  0 will always
    /// place child at beginning
    member s.InsertChild(path, parentHdl, childIdx, hdl ) =
        let parentNode = s.Node parentHdl
        let childNode = s.Node hdl
        let childIdx = 
            if childIdx > -1 && childIdx < parentNode.ChildNodes.Count
                then childIdx
                else parentNode.ChildNodes.Count
        m_preNodeInsertFire (parentHdl,childIdx,hdl)
        s.NoEventInsertChild (parentHdl,childIdx,hdl)
        m_postNodeInsertFire (parentHdl,childIdx,hdl)
        
    /// Inserts the child such that children[childIdx] = child.
    /// Inserts before the current item at childIdx
    /// -1 for childIdx means insert at the end.  0 will always
    /// place child at beginning
    member s.NoEventInsertChild (rentHdl,childIdx,hdl) =
        let parentNode = s.Node rentHdl
        let childNode = s.Node hdl
        let childIdx = 
            if childIdx > -1 
                then childIdx 
                else parentNode.ChildNodes.Count
        if ( childIdx < parentNode.ChildNodes.Count )
            then parentNode.InsertBefore( childNode, (parentNode.ChildNodes.ItemOf childIdx) ) |> ignore
            else parentNode.AppendChild( childNode ) |> ignore
            
    /// Non-undoable remove
    member s.NoEventRemoveChild (parentHdl,hdl) =
        let parentNode = s.Node parentHdl
        let childNode = s.Node hdl
        parentNode.RemoveChild childNode |> ignore
    
    member s.SetAttribute (hdl,ns,name,value) =
        let oldVal = s.GetAttribute( hdl,ns,name )
        m_preAttributeSetFire (hdl,ns,name,oldVal,value)
        s.NoEventSetAttribute (hdl,ns,name,value)
        m_postAttributeSetFire (hdl,ns,name,oldVal,value)
        
    member s.NoEventSetAttribute (hdl,ns,name,(value:string option)) =
        let node = s.Node hdl
        let oldAtt = node.Attributes.GetNamedItem( name, ns )
        match value with
            | Some strVal ->
                match oldAtt with
                    | :? XmlAttribute as att -> att.Value <- strVal
                    | _ -> 
                        let newAtt = node.OwnerDocument.CreateAttribute( name, ns )
                        newAtt.Value <- strVal
                        node.Attributes.SetNamedItem( newAtt ) |> ignore
            | None ->
                if oldAtt <> null
                    then node.Attributes.Remove( (oldAtt :?> XmlAttribute) ) |> ignore
                
                
    member s.SetElemText (path,hdl,text:string) =
        let oldVal = s.GetElemText (path,hdl)
        m_preElemTextSetFire (hdl,oldVal,text)
        s.NoEvenSetElemText (hdl,text)
        m_postElemTextSetFire (hdl,oldVal,text)
        
    member s.NoEvenSetElemText (hdl,(text:string)) =
        let elemText =
            if text = null || text.Length = 0
                then None
                else Some text
        let node = s.Node hdl
        let tempNodes = XmlNodeText node
        let tempLen = Seq.length tempNodes
        let lastNode = 
            let first = ref true
            if ( tempLen > 1 )
                then
                    List<XmlText>(tempNodes)
                        |> Seq.iter (
                            fun (tnode) -> 
                                if (not !first) 
                                    then (node.RemoveChild tnode) |> ignore
                                first := true )
                elif tempLen > 0
                    then first := false
            if ( !first ) //If true, then we didn't iterate even once.
                then None
                else Some (Seq.nth 0 tempNodes)
        match elemText with
            | Some text ->
                match lastNode with
                    | Some tnode ->
                        tnode.Value <- text
                    | None ->
                        let tnode = node.OwnerDocument.CreateTextNode(text)
                        node.AppendChild( tnode ) |> ignore
            | None ->
                match lastNode with
                    | Some tnode ->
                        node.RemoveChild( tnode ) |> ignore
                    | None -> ()
                    
                    
    member private s.CheckDocumentValidity (docEntry:DocEntry) =
        if docEntry.Document.SchemaInfo = null || docEntry.Document.SchemaInfo.Validity = XmlSchemaValidity.NotKnown
            then 
                docEntry.Document.Validate(fun a b ->failwith "Invalid document")
        
                
    member s.FindDatatypes (hdl,types,callback) =
        let node = s.Node hdl
        let docEntry = m_documentIdx.Items.[node.OwnerDocument]
        s.CheckDocumentValidity docEntry
        FindDatatypes types (s.GetOrAddItem docEntry) node callback